;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2022 Brendan Tildesley <mail@brendan.scot>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (guix import crate-git)
  #:use-module ((guix licenses) #:prefix license:)
  #:use-module ((srfi srfi-1) #:select (remove))
  #:use-module ((srfi srfi-26) #:select (cut))
  #:use-module (gnu packages)
  #:use-module (gcrypt hash)
  #:use-module (guix base32)
  #:use-module (guix build utils) ;; find-files
  #:use-module (guix http-client)
  #:use-module (guix build-system cargo)
  #:use-module (guix download)
  #:use-module (guix git)
  #:use-module (guix import crate)
  #:use-module (guix import json)
  #:use-module (guix import utils)
  #:use-module (guix memoization)
  #:use-module (guix packages)
  #:use-module (guix utils)
  #:use-module (ice-9 match)
  #:use-module (ice-9 pretty-print)
  #:use-module (ice-9 rdelim)
  #:use-module (ice-9 threads)
  #:use-module (json)
  #:use-module (semver ranges)
  #:use-module (semver)
  #:export (%crates.io-index
            lookup-crate-data
            crate-data-path))

;;;;;;;;;;;;;;;;;;;;;;;;
;; TODO: I need to re introduced yanked crates since they are depended upon.
;; pref them above pre-release?
;; TODO: watch out for upper-cased package names
;;;;;;;;;;;;;;;;;;;;;;;;
;;(define make-crate-sexp (@@ (guix import crate) make-crate-sexp))
(define %crates.io-index-uri "https://github.com/rust-lang/crates.io-index")
(define %crates.io-index "/home/b/code/git/crates.io-index")
;;XXX: Use guix-name
(define %PREFIX "RUST-")
(define %prefix "rust-")

(define (pre-release sv)
  (not (null? (semver-pre sv))))

(define (sort-semvers semvers)
  "Sort a list of semvers from greatest to least with semver>? comparison."
  (sort-list semvers semver>?))

(define (sort-semvers/stable-first semvers)
  "Sort a list of semvers from \"best\" to worst, where best means latest that
is not a pre-release. Pre-releases are sorted strictly below all stable releases."
  (append (sort-list (filter (negate pre-release) semvers) semver>?)
          (sort-list (filter pre-release semvers) semver>?)))

(define (first-compatible-version semvers range)
  "Return the first version in SEMVERS compatible with RANGE."
  (cond [(null? semvers) (error "no compatible version or version within range:" range)]
        [(semver-range-contains? range (car semvers)
                                 #:include-prerelease? #t)
         (car semvers)]
        [#true (first-compatible-version (cdr semvers) range)]))

(define (best-version semvers range)
  "Return the most recent version in SEMVERS within the RANGE, choosing a
pre-release version only if no compatible stable version is available."
  (first-compatible-version (sort-semvers/stable-first semvers) range))

(define (crate-data-path name)
  (let ((name (string-downcase name))
        (len (string-length name)))
    ;; Arbitrary sensible upper limit.
    (cond [(>= 1000 len 4) (string-append %crates.io-index "/"
                                          (substring name 0 2) "/"
                                          (substring name 2 4) "/"
                                          name)]
          [(= len 3) (string-append %crates.io-index "/3/"
                                    (substring name 0 1) "/"
                                    name)]
          [(member len '(1 2)) (string-append %crates.io-index "/"
                                              (number->string len) "/"
                                              name)]
          [#true (error "length doesn't make sense.")])))

(define lookup-crate-data
  (memoize
   (lambda (name)
     (map json-string->scm
          (with-input-from-file (crate-data-path name)
            read-lines))
     ;; (let [(data )
     ;;       ;; (yanked? (cut assoc-ref <> "yanked"))
     ;;       ]
     ;;                                    ;(remove yanked? data)
     ;;   data)
     )))

(define* (lookup-crate-data-for-version name #:optional version)
  (let ((data (lookup-crate-data name))
        (list-ref-last (lambda (l) (list-ref l (- (length l) 1)))))
    (if version
        (match
            (filter (lambda (data-for-version)
                      (string=? version (assoc-ref data-for-version "vers")))
                    data)
          [(x) x] ;; should be a list of only one result.
          [(x ...) (error "More than one result in " x ", or none????")]
          [_ (error "I'm confused")])
        ;; Assume sorted and show latest
        (list-ref-last data))))

;;cfg(target_arch = "wasm32")
;;cfg(unix)
(define lookup-crate-inputs
  (memoize
   (lambda* (name #:optional version
                  #:key prepend-kind?)
     (let* ((data (lookup-crate-data-for-version name version))
            (name (assoc-ref data "name"))
            (deps (vector->list (assoc-ref data "deps")))
            ;; XXX: duplicate deps with target exist
            ;; (deps (filter (lambda (dep)
            ;;                 (eqv? 'null (assoc-ref dep "target")))
            ;;               deps))
            (deps-crate-versions (map
                                  (lambda (dep)
                                    ;; all versions for crate
                                    (let* ((dep-name (assoc-ref dep "name"))
                                           ;; XXX: turns out the dep name and the
                                           ;; actual crate it refers to can be
                                           ;; different
                                           (package-name (assoc-ref dep "package"))
                                           (dep-name* (or package-name dep-name))
                                           (dep-data (lookup-crate-data dep-name*)))
                                      (cons dep-name
                                            (map string->semver
                                                 (map (cut assoc-ref <> "vers")
                                                      dep-data)))))
                                  deps))
            (dep+best-version (lambda (dep)
                                (let* ((dep-name (assoc-ref dep "name"))
                                       (package-name (assoc-ref dep "package"))
                                       (dep-name* (or package-name dep-name))
                                       (req (assoc-ref dep "req"))
                                       (kind (assoc-ref dep "kind"))
                                       (req* (string->semver-range req))
                                       (dep-versions-available (assoc-ref deps-crate-versions dep-name))
                                       (dep-version-best
                                        (begin
                                          (display name) (display " ") (display (assoc-ref data "vers"))
                                          (display " needs: ")
                                          (display dep-name*) (display " ") (display req) (display " choosing: ")
                                          (let [(dep-version-best (best-version dep-versions-available req*))]
                                            (display dep-version-best)
                                            (newline)
                                            dep-version-best))))

                                  (if prepend-kind?
                                      (list
                                       kind
                                       dep-name*
                                       (semver->string dep-version-best))
                                      (list
                                       dep-name*
                                       (semver->string dep-version-best)))))))
       (map dep+best-version deps)))))

;; find all inputs that aren't already listed
(define* (lookup-all-requirements name #:optional version)
  (define (name+version<=? a b)
    ;; sort alphabetically, but latest version at top
    (if (string= (car a) (car b))
        (semver>=? (string->semver (cadr a))
                   (string->semver (cadr b)))
        (string<= (car a) (car b))))
  ;; will get latest if no version specified
  (let* [(data (lookup-crate-data-for-version name version))
         (name+version (list name (or version (assoc-ref data "vers"))))]
    (let loop [(crates-required (list name+version))
               (crates-to-inspect (list name+version))]
      (let* [(inputs (apply append
                            (n-par-map (current-processor-count) ; (parallel-job-count)
                                       (lambda (name+version)
                                         (apply lookup-crate-inputs name+version))
                                       crates-to-inspect)))
             ;; the list of inputs of inputs will often have duplicates.
             (new-inputs (delete-duplicates
                          (remove (cut member <> crates-required)
                                  inputs)))]
        (if (null? new-inputs)
            (sort-list crates-required
                       name+version<=?)
            (loop (append crates-required new-inputs)
                  new-inputs))))))

(define _lookup-crate-tarball-hash
  (memoize
   (lambda (name version)
     (let ((port (http-fetch (crate-uri name version))))
       (bytevector->nix-base32-string (port-sha256 port))))))



(define lookup-crate-tarball-hash
  (lambda (name version)
    (let* ((cache-file "../../gnu/packages/crates-hashes.scm")
           (tarball-name (string-append %prefix name "-" version ".tar.gz"))
           (cache (if (file-exists? cache-file)
                      (with-input-from-file cache-file read)
                      '())))
      (or (assoc-ref cache tarball-name)
          (let* ((checksum (bytevector->nix-base32-string
                            (port-sha256
                             (http-fetch (crate-uri name version)))))
                 (new-cache
                  (sort-list (cons (cons tarball-name checksum) cache)
                             (lambda (a b) (string<= (car a) (car b))))))
            (call-with-output-file cache-file
              (lambda (port)
                (pretty-print new-cache port
                              #:width 200 #:max-expr-width 200)))
            checksum)))))

(define* (make-crate-package-definition name version)
  (define (package-symbol-string name version)
    (string-append %prefix name "-" version))
  (define (package-symbol name version)
    (string->symbol
     (string-append %prefix name "-" version)))

  (define inputs (lookup-crate-inputs name version #:prepend-kind? #t))

  `(define-public ,(package-symbol name version)
     (package
       (name ,(string-append %prefix name))
       (version ,version)
       (source (origin
                 (method url-fetch)
                 (uri (crate-uri ,name ,version))
                 (file-name (string-append name "-" version ".tar.gz"))
                 (sha256 ;; TODO: get hashes somehow
                  (base32 ,(lookup-crate-tarball-hash name version)))))
       (build-system cargo-build-system)
       (arguments
        (list #:tests? #f
              #:cargo-inputs
              ,(cons* 'list
                      (map (lambda (l)
                             (list 'list
                                   (package-symbol-string (list-ref l 1)
                                                          (list-ref l 2))
                                   (package-symbol (list-ref l 1)
                                                   (list-ref l 2))))
                           (filter (lambda (dep-data)
                                     (or (string=? (car dep-data) "normal")
                                         ;; XXX: I assume we need build deps too?
                                         (string=? (car dep-data) "build")))
                                   inputs)))
              #:cargo-development-inputs
              ,(cons* 'list
                      (map (lambda (l)
                             (list 'list
                                   (package-symbol-string (list-ref l 1)
                                                          (list-ref l 2))
                                   (package-symbol (list-ref l 1)
                                                   (list-ref l 2))))
                           (filter (lambda (dep-data)
                                     (string=? (car dep-data) "dev"))
                                   inputs)))))
       (home-page #f)
       (synopsis #f)
       (description #f)
       (license #f))))


(define bevy-deps (lookup-all-requirements "bevy"))
(define bevy-deps-definitions
  (map (lambda (name+version)
         (make-crate-package-definition (list-ref name+version 0)
                                        (list-ref name+version 1)))
       bevy-deps))

(call-with-output-file "/home/b/code/guix-rust/gnu/packages/crates-all.scm"
  (lambda (port)
    (display "\
(define-module (gnu packages crates-all)
  #:use-module (guix build-system cargo)
  #:use-module (guix download)
  #:use-module (guix packages)
  #:use-module (gnu packages)
  #:use-module (gnu packages pkg-config)
  #:use-module (gnu packages linux)) ;alsa-sys requires alsa-lib

"
             port)
    (for-each
     (lambda (definition)
       (pretty-print definition port
                     #:width 100
                     #:max-expr-width 170)
       (newline port))
     bevy-deps-definitions)))

#;
(define* (_make-crate-package-definition name #:optional version)
(let* ((data (lookup-crate-data-for-version name))
(name (assoc-ref data "name"))
(vers (or version (assoc-ref data "vers")))
(deps (vector->list (assoc-ref data "deps")))
;; XXX: duplicate deps with target exist
(deps (filter (lambda (d)
(eqv? 'null (assoc-ref d "target")))
deps))

;;TODO: memoize this?
(deps-crate-versions (map
(lambda (dep)
;; all versions for crate
(let* ((dep-name (assoc-ref dep "name"))
(package-name (assoc-ref dep "package"))
(dep-name* (or package-name dep-name))
(dep-data (lookup-crate-data dep-name*)))
(cons dep-name*
(map string->semver
(map (cut assoc-ref <> "vers")
dep-data)))))
deps))

(deps* (map (lambda (dep)
(let* ((dep-name (assoc-ref dep "name"))
(package-name (assoc-ref dep "package"))
(dep-name* (or package-name dep-name))
(req (assoc-ref dep "req"))
(req* (string->semver-range req))
(dep-versions-available (assoc-ref deps-crate-versions dep-name*))
(dep-versions-compatible
;; NOTE: not sure if already sorted (reversed)
(sort-list
(filter
(lambda (version) (semver-range-contains? req* version))
dep-versions-available)
semver>?))
(dep-version-best (car dep-versions-compatible)))

(list (assoc-ref dep "kind")
dep-name*
(string->symbol
(string-append
%PREFIX
dep-name*
"-" ;; TODO: should we not use patch version?
(semver->string dep-version-best))))))
deps)))

`(define-public ,(string->symbol (string-append %PREFIX name "-" vers))
(package
(name ,(string-append %PREFIX name))
(version ,vers)
(source (origin
(method url-fetch)
(uri (crate-uri ,name ,vers))
(file-name (string-append name "-" version ".tar.gz"))
(sha256
(base32 "1zzz78231w849xslz9s0pwjj6gp02wfbbxdpysqhwwq1vqr5xznr"))))
;; TODO: get hashes somehow
(build-system cargo-build-system)
;; TODO: check if sorted
(arguments
(list #:cargo-inputs
,(cons* 'list (map (lambda (l) (cons* 'list (cdr l)))
(filter (lambda (dep-data)
(or (string=? (car dep-data) "normal")
;; XXX: I assume we need build deps too?
(string=? (car dep-data) "build")))
deps*)))
#:cargo-development-inputs
,(cons* 'list (map (lambda (l) (cons* 'list (cdr l)))
(filter (lambda (dep-data)
(string=? (car dep-data) "dev"))
deps*)))))
(home-page #f)
(synopsis #f)
(description #f)
(license #f)))))

;; (define make-crate-package-definition
;;   (memoize %make-crate-package-definition))

#;
(define png-deps
(match png
[(("links" . links)
("yanked" . yanked)
("features" . features)
("cksum" . cksum)
("deps" . #(deps ...))
("vers" . vers)
("name" . name))

`(define-public ,(string->symbol (string-append "RUST-" name "-" vers))
(package
(name ,name)
(version ,vers)
(source (origin
(method url-fetch)
(uri (crate-uri ,name ,vers))
(file-name (string-append name "-" version ".tar.gz"))
(sha256
(base32 #f)))) ;; TODO: get hashes somehow
(build-system cargo-build-system)
(arguments
,(let ((deps*
(map (lambda (dep)
(match dep
[(("kind" . kind)
("target" . target)
("default_features" . default_features) ;; TODO: what does this mean
("optional" . optional)
("features" . #(features ...))
("req" . req)
("name" . dep-name))

;; (filter (lambda (dep)
;;           (string=? kind "normal")) deps)
(list kind
dep-name
;; TODO: find best version
(let ((dep-crate-data (crate-data dep-name)))
;; (match dep-crate-data
;;     [(("links" . _)
;;       ("yanked" . _)
;;       ("features" . _)
;;       ("cksum" . _)
;;       ("deps" . _)
;;       ("vers" . vers)
;;       ("name" . _))
;;      vers])
1
)

;; features
)
]))
deps)))
`'(#:cargo-inputs
,(map cdr
(filter (lambda (dep-data)
(or (string=? (car dep-data) "normal")
;; XXX: I assume we need build deps too?
(string=? (car dep-data) "build")))
deps*))
#:cargo-development-inputs
,(map cdr
(filter (lambda (dep-data)
(string=? (car dep-data) "dev"))
deps*)))

))
(home-page #f)
(synopsis #f)
(description #f)
(license #f)))
]))




#;
(source
(origin
(method url-fetch)
(uri (crate-uri "abomonation" version))
(file-name
(string-append name "-" version ".tar.gz"))
(sha256
(base32
"1cjg3hjf028n447pdj7zcdgrkngx30as8ndxlxx947wvr49jkrsn"))))
